home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 003 / dba1286.arc / DEMO.PRG < prev    next >
Encoding:
Text File  |  1986-11-04  |  3.3 KB  |  146 lines
  1. *Filename: demo.PRG
  2. *Program:
  3. *Author:J. Ari Kornfeld
  4. *Date  :2-11-86
  5. *Notes :Uses files: DEMO.DBF, DEMO.NTX, HELP.DBF, HELP.NTX
  6. * CONSTANT DEFINITIONS
  7. * SpecExit = PgUp, PgDn, ^PgUp, ^PgDn, Esc
  8. SpecExit = CHR(18)+CHR(3)+CHR(31)+CHR(30)+CHR(27)
  9. Esc = CHR(27)
  10. * frame for a window (and it fills the window with blanks)
  11. frame = CHR(201)+CHR(205)+CHR(187)+CHR(186)+CHR(188)+CHR(205)+CHR(200);
  12.        +CHR(186)+" "
  13. * Standard colors: Normal, Help, Error and RO (Read-Only fields)
  14. * NormHilite set the non-hi color to imitate the hilite color
  15. NormColor = "W+/ , /W"
  16. NormHilite = " /W"
  17. HelpColor = "GR+"
  18. ErrorColor = "BG+"
  19. ROColor   = "B+"
  20. FrameColor = "R+"
  21.  
  22. SET DELETED ON
  23. SET EXACT ON
  24. SET COLOR TO &NormColor
  25. SET CONFIRM ON
  26. SET BELL OFF
  27. USE Demo INDEX Demo ALIAS Names
  28. DO DispSay
  29. Mparcel = 99999
  30. Mparcel = Mparcel + 1
  31. Msupplier = SPACE(LEN(Names->id))
  32. Mdate = DATE()
  33. Mquantity = 0
  34. Mweight = 0.00
  35. DO DispGet
  36. READ
  37. RETURN
  38.  
  39. PROCEDURE DispSay
  40. CLEAR
  41. @ 2,47 SAY "Parcel No.:"
  42. @ 3,8 SAY "Supplier's ID Code:"
  43. @ 5,8 SAY "Company Name:"
  44. @ 6,8 SAY "Address:"
  45. @ 9,43 SAY "Date Received:"
  46. @ 10,8 SAY "Quantity:"
  47. @ 12,8 SAY "Weight:"
  48. @ 12,43 SAY "Average Weight:"
  49. RETURN
  50.  
  51. PROCEDURE DispSay2
  52. PRIVATE lastcol, color
  53. * Company info
  54. SET COLOR TO &NormHilite
  55. @ 3,30 SAY Names->id
  56. SET COLOR TO &ROcolor
  57. @ 5,24 SAY Names->company
  58. @ 6,24 SAY Names->address
  59. lastcol = COL()
  60. @ 7,24 SAY TRIM(Names->city)+", "+TRIM(Names->state)+" "+TRIM(names->zip);
  61.    +" "+TRIM(names->country)
  62. IF COL() < lastcol
  63.   @7,COL() SAY SPACE(lastcol - COL())
  64. ENDIF
  65. SET COLOR TO &NormColor
  66. @ 7,COL()
  67. RETURN
  68.  
  69. PROCEDURE DispGet
  70. SET COLOR TO &ROcolor
  71. @ 2,61 SAY Mparcel  PICTURE "999999"
  72. SET COLOR TO &NormColor
  73. @ 3,30 GET Msupplier PICTURE "@!" VALID ValSup()
  74. @ 9,59 GET Mdate
  75. @ 10,19 GET Mquantity VALID ValQuan(Mquantity)
  76. @ 12,19 GET Mweight PICTURE "@Z" VALID ValAveW(Mweight, Mquantity)
  77. RETURN
  78.  
  79. FUNCTION ValSup
  80. PRIVATE ok
  81. IF LEN(TRIM(Msupplier)) = 0
  82.   SET COLOR TO &FrameColor
  83.   SAVE SCREEN
  84.   @1,38, 4,70 BOX frame
  85.   SET COLOR TO &ErrorColor
  86.   @2,40 SAY "  This field must be filled."
  87.   @3,40 SAY "Press any key to continue."
  88.   DO WHILE INKEY() = 0
  89.   ENDDO
  90.   RESTORE SCREEN
  91.   SET COLOR TO &NormColor
  92.   ok = .f.
  93. ELSE
  94.   SEEK Msupplier
  95.   IF EOF()
  96.     DO CloseMat WITH Msupplier, [DispSay2], [c:demo.ntx]
  97.     Msupplier = id 
  98.   ENDIF
  99.   DO DispSay2
  100.   ok = IF(LASTKEY() = 27, .F., .T.)
  101. ENDIF
  102. RETURN (ok)
  103.  
  104. FUNCTION ValQuan
  105. PARAMETER Mquantity
  106. PRIVATE ok
  107. IF Mquantity < 1 .OR. Mquantity > 99
  108.   SET COLOR TO &FrameColor
  109.   SAVE SCREEN
  110.   @1,38, 4,70 BOX frame
  111.   SET COLOR TO &ErrorColor
  112.   @2,40 SAY "    RANGE:  1 to 99"
  113.   @3,40 SAY "Press any key to continue."
  114.   DO WHILE INKEY() = 0
  115.   ENDDO
  116.   RESTORE SCREEN
  117.   SET COLOR TO &NormColor
  118.   ok = .f.
  119. ELSE
  120.   ok = .t.
  121. ENDIF
  122. RETURN (ok)
  123.  
  124. FUNCTION ValAveW
  125. PARAMETERS Mweight, Mquantity
  126. PRIVATE ok
  127. DO CASE
  128.    CASE Mweight < 0.01 .or. Mweight > 999.99 
  129.      SET COLOR TO &FrameColor
  130.      SAVE SCREEN
  131.      @1,38, 4,70 BOX frame
  132.      SET COLOR TO &ErrorColor
  133.      @2,40 SAY "  RANGE: 0.01 to 999.99"
  134.      @3,40 SAY "Press any key to continue."
  135.      DO WHILE INKEY() = 0
  136.      ENDDO
  137.      RESTORE SCREEN
  138.      ok = .f.
  139.    OTHERWISE
  140.      SET COLOR TO &ROcolor
  141.      @12,59 SAY Mweight/Mquantity PICTURE "999.99"
  142.      ok = .t.
  143. ENDCASE
  144. SET COLOR TO &NormColor
  145. RETURN (ok)
  146.